perm filename ALPHA.F4[P11,LCS]1 blob
sn#573356 filedate 1981-03-15 generic text, type T, neo UTF8
00100 C****** FOR LISTS OF LETTERS, ETC. AND TRILL *******
00200 SUBROUTINE ALPHA
00220 INTEGER FNAME,POS
00240 DIMENSION FNAME(4)
00300 COMMON /PLTR/IPLT,RHT,DIS /FONT/JFONT /NFONT/NFONT
00400 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
00405 COMMON/ALF/INP(10),OLDX /OLDTOP/OLDY
00500 EQUIVALENCE(J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
00600 1(R8,RJQ(6)),(NRJ,RJQ(8)),(JX,JQ(11)),
00700 1(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
00800 1,(J6,JQ(4)),(R7,RJQ(5)),(R4,RJQ(2)),(IFNT,JQ(13)),(J11,JQ(9)),
00900 1(RY,JQ(16)),(RX,JQ(17)),(RZ,JQ(18)),(RW
01000 1,JQ(19)),(RB,JQ(20)),(R,RJQ(20)),(FILL,RJQ(19)),(R9,RJQ(7))
01100 1,(JTR,RJQ(17)),(RF,RJQ(15)),(JR3,RJQ(14)),(R3,RJQ(1))
01200 1,(R10,RJQ(8)),(R11,RJQ(9)),(R12,RJQ(10))
01300 COMMON/STF/RSTFAC(8),RSTJ2 /POSI/STFF(8),JJ2,POS
01400 DATA R4X/-2.1/,IFNT/1/,BLANK/0.7/,NFONT/'BDR40'/
01420 1,FNAME/'PRIM0','BDR40','BDI40','BDL40'/
01450 C SEE NEW SIZE FOR 'BLANK'=.7 (OLD SIZE=1.0, CHANGE IN DDT IF NECESSARY)
01500
01600 IF(JA.EQ.7)GO TO 20
01700 JTR=99
01800 IF(R5.GE.100)R5=R5-100
01900 C >100 FOR TEXT IN ORCH SCORES FOR ALL SEP. PARTS.
02000 C PRIMITIVE IS DEFAULT FONT. #=SET BACK TO PRIM.
02100 C ONLY 11 LETTERS WITHOUT FONT RESET.
02110 JF=-JFONT
02120 IF(JFONT.GE.0)GO TO 540
02140 JFONT=1
02160 NFONT=FNAME(JF)
02180 GO TO 54
02200 540 IF(NFONT.EQ.'PRIM0')GO TO 54
02300 IF(NFONT.EQ.'BDI40')GO TO 54
02400 NFONT='BDR40'
02500 C THE ABOVE IN CASE FONT IS NOT ESTABLISHED.
02600 54 R=19.7*R5*RSTJ2
02700 RB=J3
02800 RW=R4
02900 J9=0
03000 C J9=0 AVOIDS ROTATION IN 'CLEFS'
03100 DO 50 KA=4,6
03200 NXZ=-1
03300 RZ=RJQ(KA)
03400 CC JY=RZ
03500 CC IF(JY.NE.RZ)GO TO 130
03600 CC IF(JY.EQ.RZ)GO TO 13
03700 C WILL LOSE ON "0AB0" IN OLD FILES**************
03800 CC IF(JY.GT.999999)GO TO 13
03900 CC130 RZ=100.*RZ
04000 C FOR OLD FORMAT OF CODE 16
04100 13 JY=RZ+.2
04200 JX=1000000
04300 DO 53 LA=1,4
04400 J5=JY/JX
04500 J5X=J5
04600 R3=J3
04700 IF(J5.EQ.99)GO TO 55
04800 73 IF(KFNT)IFNT=1
04900 C READS OLD SYS. AND NEW AUTOMATIC LWR CASE.
05000 IF(J5.LT.70)GO TO 72
05100 KFNT=-1
05200 C SETS AUTOMATIC LOWER CASE FLAG.
05300 IFNT=-1
05400 C 60 ADDED FOR LOWER CASE LETTERS.
05500 J5=J5-60
05600 C NO MORE IN THIS WD.
05700 72 IF(J5.LT.48)GO TO 1
05750 IF(J5.NE.48)GO TO 172
05775 NFONT='BDL40'
05787 IF(JFONT.LT.0)GO TO 9
05793 GO TO 11
05800 172 GO TO(2,3,9,4,5),J5-49
05900 C SWITCHES FOR DIFF. FONTS.(55 MAKES ')48=UPR,49=LWR,50=BDR,51=BDI,52=PRM
06000 C ********* UPPER AND LOWER NUMBERS(48,49) NO LONGER NEEDED.(SEE 73 ↑)
06100 IF(J5.GT.55)GO TO 10
06200 J5=36
06300 R4=R4+2.9*R5
06400 C 55 WILL MAKE ' --- 56=? 57=! (THEY COME AFTER y z IN BDR46)
06500 GO TO 1
06600 10 J5=J5+6
06700 NRX=NFONT
06800 NXZ=0
06900 NFONT='BDR40'
07000 NJF=JFONT
07100 JFONT=-1
07200 GO TO 1
07300 2 NFONT='BDR40'
07400 C &=NON-ITALICS -- JFONT IS TEMPORARY SWITCH 5/74
07500 IF(JFONT.LT.0)GO TO 9
07600 GO TO 11
07700 CC GO TO 8
07800 3 NFONT='BDI40'
07900 C @=51=ITALICS
08000 IF(JFONT.LT.0)GO TO 9
08100 C TYPE '44 -1' TO MAKE ALL FONTS INTO 'PRIM'
08200 CC8 IF(IFNT.EQ.0)IFNT=-1
08300 GO TO 11
08400 4 FILL=-2
08500 GO TO 11
08600 5 FILL=0
08700 GO TO 11
08800 9 NFONT='PRIM0'
08900 GO TO 11
08905 1 IF(J5.LT.70)GO TO 12
08910 IF(J5.GE.76)GO TO 12
08915 IF(J5.NE.75)GO TO 112
08920 J5=70
08925 GO TO 12
08930 112 NFONT='BDI40'
08935 J5=J5-6
08940 GO TO 71
08945 12 J5OLD=J5
08950 IF(J5.LT.64)GO TO 212
08955 J5X=J5
08960 IF(J5.LE.65)J5X=J5X-6
08965 IF(J5.EQ.70)J5X=J5X-1
08970 J5=J5X
09000 212 CALL SPACER(J5,IFNT,RB,R)
09100 IF(J5.GT.60)GO TO 71
09200 C NOW 62=? 63=! IN BDR46
09300 IF(J5-47)7,6,11
09330 7 IF(R11.NE.0.AND.R12.EQ.0)GO TO 79
09400 IF(JFONT)78,78,77
09460 79 R9=R11
09470 J9=-1
09471 C FOR ROTATION, IF ANY. R11=ROTATION(CLOCKWISE) IN DEGREES.
09487 GO TO 77
09500 277 IF(NFONT.NE.'PRIM0')GO TO 70
09505 IF(IFNT.GE.0)GO TO 30
09510 IF(J5.GE.10)GO TO 71
09515 GO TO 30
09520 177 J5=J5+22
09525 C (=62 )=63 IN BDI (BDI46)
09530 NRX=NFONT
09535 C SAVE OLD FILE NAME
09540 NFONT='BDI40'
09545 NJF=JFONT
09550 C SAVE FONT FLAG
09555 NXZ=0
09560 C FLAG TO GET BACK RIGHT FLAGS BEFORE 30
09565 GO TO 71
09680 78 IF(IPLT.GE.0)GO TO 30
09685 C JFONT=0 FOR FIXED WIDTH OF FONTS. = AND ONLY DPYS PRIMITIVE.
09700 CC J5=J6
09800 CC IF(IFNT.EQ.0)GO TO 30
09900 CC77 IF(J5.GE.36)GO TO 30
09905 77 IF(J5.LT.36)GO TO 277
09910 IF(J5.EQ.40.OR.J5.EQ.41)GO TO 177
09912 C FOR LEFT AND RIGHT PARENTH.
09915 IF(J5.NE.43)GO TO 30
09920 C ASTERISK
10000 C PUNCTUATION AND SPACE.
10100 IF(NFONT.EQ.'PRIM0')GO TO 30
10105 IF(NFONT.EQ.'BDI40')GO TO 77
10110 NRX=NFONT
10115 NXZ=0
10120 NJF=J5
10125 NFONT='BDI40'
10130 777 J5=69
10135 GO TO 71
10200 CZ IF(IFNT.GE.0)GO TO 30
10300 CC*** WAS (IFNT.EQ.1) ???? 1/76
10400 CZ IF(J5.LT.10)GO TO 30
10500 C JUMP TO USE UPPER CASE PRIM. LOWER CASE STARTS IN PRIM1.
10600 CZ GO TO 71
10700 70 IF(J5.LE.9)GO TO 71
10800 IF(IFNT.LT.0)J5=J5+26
10900 71 RX=R6
11000 R6=R5*.28
11100 C .29 IS SIZE FACTOR -- PERHAPS CHANGE SIZE IN FONT TO =1.
11200 RY=R7
11300 R7=R6
11400 RZ=R8
11500 R4=R4+R4X
11600 C SHIFTS DOWN ??? WHY NOT GET RID OF THIS.??
11700 J8=FILL
11800 NRJ=NFONT
11900 C GETS RIGHT FILE
11905 R8=0
11910 C TO AVOID THICKENER IN 'CLEFS'
12000 JA=12
12100 C ANY NON-11 NUMBER .GT.10 WILL DO.
12300 CALL CLEFS
12400 R6=RX
12500 R7=RY
12600 R8=RZ
12700 C PUTS BACK RIGHT STUFF
12800 IF(NXZ.LT.0)GO TO 6
12900 NFONT=NRX
13000 JFONT=NJF
13100 GO TO 6
13200
13300 30 J7=0
13400 R6=R5
13500 CALL PNUM
13600 C 47=BLANK (WAS 99)
13700 6 J3=ROFF(RB)
13800 R4=RW
13900 11 JY=JY-J5X*JX
14000 C TO GET NEXT NUM OUT OF JY
14100 53 JX=JX/100
14200 50 CONTINUE
14300 55 IF(JTR.NE.99)GO TO 52
14305 NSAV=NFONT
14310 GO TO 100
14500
14700 C FOR TRILLS
14800 C 7, POS1, STF, NT#, SIZE, POS2, X IF X=1 THEN NO WAVEY LINE
14900 20 RF=R6
14905 NSAV=NFONT
14910 C SAVE THE FONT NAME. GET IT BACK AT END.
14915 JTRILL=J7
15000 IF(J7.LE.1)GO TO 200
15100 IF(J7.GE.8)GO TO 201
15200 C JUMP FOR OTTAVA
15300 C NEXT FOR SPECIAL PEDAL MARKS.
15400
15500 C PEDAL: 7,STF,POS,0=STND POS,NNN=PEDS,POS2,BRACK #S,LFT POS BRK.
15600 C P5=101 MEANS LFT & RT PEDS., P7=2 NO BRK, =3 --!, =4 ----
15700 RW=R8
15800 RB=R3
15900 NFONT=J7
16000 JY=J5
16100 CALL NOZERO(R9)
16200 RY=R9
16300 RX=23.84*R9*RSTJ2
16400 R6=.45*RY
16500 J9=0
16600 J5=18
16700 C IN FILE CLEF1.DMD
16800 JA=3
16900 R5=0
17000 R7=0
17100 R4=R4-6
17200 C STANDARD POS IS AT -6 ****** (I.E. P4=0 PUTS TOP OF IT AT -6)
17300 CALL CLEFS
17305 R8=0
17400 IF(JY.EQ.0)GO TO 222
17500 R8=-1
17600 J5=19
17700 IF(JY.LT.100)GO TO 203
17800 JY=JY-100
17900 CALL CLEFS
18000 203 R3=RB+RX
18100 IF(JY.LT.10)GO TO 204
18200 JY=JY-10
18300 CALL CLEFS
18400 204 R3=RB+RX+RX
18500 IF(JY.NE.0)CALL CLEFS
18600 C PRINTS THE 3 BOTTOM ITEMS
18700
18800 222 IF(NFONT.EQ.2)GO TO 2222
18900 IF(RW.NE.0)R3=RB-5.96*RW
19000 C FOR BRACKET
19100 RX=POS
19200 R6=RF
19300 R4=R4+3.
19400 R5=R4
19500 J7=0
19600 R7=0
19700 R8=0
19800 R10=0
19900 206 CALL ITMSUB
20000 IF(NFONT.EQ.4)GO TO 2222
20100 C R7=4= NO END ON BRKT.
20105 IF(NFONT.EQ.5)GO TO 2206
20110 OLDY=10.*RY*RSTJ2
20112 C THIS WILL BE VERTICAL PART OF BRACK. END.
20113 C THE COORD. FROM LAST LINES CALL
20115 CALL LINES(OLDX,OLDY,2)
20120 C OLDX WAS LAST X COORD. IN ITMSUB **************
20125 GO TO 2222
20200 CZ POS=RX
20300 C POS GOT RUINED IN ITMSUB.
20400 CZ R3=ROFF(RHORZ(RF))
20500 CZ R5=R5+1.4*RY
20600 CZ CALL ITMSUB
20700 CZ RETURN
20800
20805 2206 RARR=2.25*RY*RSTJ2
20810 R4=R4+2.12
20815 JA=4
20820 J5=50
20825 C FOR CRESC.
20830 RYY=1.29*RY
20835 R6=RF
20840 R3=(R6-RARR)*5.96-596.
20845 R7=-RYY
20850 CALL ITMSUB
20852 C GO DRAW CRESC.
20855 GO TO 2222
20900 C NEXT FOR 8VA BASSA
21000 202 R7=47717088.
21100 R8=88709999.
21200 RR10=138.
21300 R6=51089170.
21400 GO TO 214
21500 201 CALL NOZERO(R5)
21600 IF(J7.EQ.15)GO TO 205
21700 R6=51089170.
21800 C NEXT = 8VA
21900 RR10=47.
22000 R7=99999999.0
22100 214 RR5=R5*RSTJ2
22200 RR3=R3+RR10*RR5
22300 C SAVE FOR POS. OF DASHES
22400 JTR=-1
22500 J4=J7
22600 J10=J8
22700 C SAVE THESE IN PARAMS NOT USED IN ALPHA
22800 GO TO 2212
22900
23000 C 15MA - - - - -
23100 205 R6=51010582.
23200 R7=70999999.
23300 RR10=56.
23400 GO TO 214
23500
23600 C NEXT FOR THE DASHES. J8=1 =NO END BRACK.
23700 213 R8=1.8*RR5
23800 R9=0
23900 R3=RR3
24000 R6=RF
24100 R4=R4+.7*RSTJ2
24200 R5=R4
24300 J5=J4
24400 J11=-1
24500 IF(J4)J11=-J11
24600 IF(J10.NE.0)J11=0
24700 J7=1
24800 J10=0
24900 C GO DRAW THE DASHES
25000 CALL ITMSUB
25100 GO TO 2222
25200
25300 200 CALL NOZERO(R5)
25400 IF(J7.EQ.-8)GO TO 202
25500 RR10=R5
25600 C ↑↑↑↑↑ R10 GETS WIPED OUT IN ALPHA OR CLEFS.
25700 J3=J3+6.*RSTJ2
25800 JR3=J3
25900 R6=51898799.0
26000 C @tr LWR CASE, ITAL. TR
26100 R7=0
26200 R8=R7
26300 JTR=J7
26400 2212 R5=.8*R5
26500 GO TO 54
26600 52 J5=R8
26650 C FOR ACCI OVER TR
26662 K=POS
26668 C SAVE POS IN K FOR ACCI ROUTINE
26675 IF(JTR.NE.0)GO TO 1000
26700 C GO TO 100 IF NO WAVY LINE IS NEEDED. J7=1=NO, 0=YES
26800 R3=JR3+20.*RSTJ2*RR10
26900 JA=4
27000 J7=-2
27100 C J7 IS SWITCH TO DRAW WIGGLE
27200 R6=RF
27300 R9=.7*RR10
27400 C SETS WIGGLE HEIGHT
27500 R8=.9*RR10
27600 C RR10 IS SIZE (P5)
27700 J10=0
27800 IF(IPLT.LT.0)J10=1
27900 CALL ITMSUB
28000 C SINGLE WIGGLE ON DPY, DOUBLE ON PLOTTER.
28010 1000 IF(JTRILL.LT.0.OR.JTRILL.GT.1)GO TO 100
28020 C NEXT PUTS ACCI OVER TR IF 1, 2 OR 3 IN P8
28030 C IF JTRILL(J7)=0 OF 1 IT'S A TRILL, ELSE GO TO 2222
28040 C IF R8=0 GOTO 2222 (R8 HAS ACCI NUM)
28050 IF(R8.EQ.0)GO TO 100
28060 POS=K
28070 C GET BACK POS. (IT GOT CHANGED IN "WIGGLE")
28080 CENTR=CENTR+27.*RSTJ2
28090 R6=R5*.9
28100 R3=J3-14.*RSTJ2
28110 R4=R4+3.75
28120 R7=0
28130 R8=0
28140 R9=0
28150 JA=9
28160 C NOW GO MAKE AN ACCI.
28170 CALL NOTWRT
28250 100 IF(JTR.LT.0)GO TO 213
28275 IF(KFNT.LT.0)IFNT=1
28300 KFNT=0
28400 2222 NFONT=NSAV
28410 C GET BACK ORIGINAL FONT NAME
28420 END